home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr01 / halcn305.zip / GSOB_DTE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-05-02  |  12KB  |  439 lines
  1. unit GSOB_Dte;
  2. {-----------------------------------------------------------------------------
  3.                              Date Processor
  4.  
  5.        GSOB_DTE Copyright (c)  Richard F. Griffin
  6.  
  7.        02 April 1993
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles date conversion.
  14.  
  15.                    SHAREWARE  -- COMMERCIAL USE RESTRICTED
  16.  
  17.        Changes:
  18.  
  19.             07 Feb 93 - Added GS_Date_CurCentury to return the current
  20.                         century (i.e., '19' for 1992) based on the date
  21.                         in the computer.  This replaced the embedded
  22.                         constant '19' found before.  This is just in case
  23.                         the routine is needed after the year 2000!
  24.  
  25.  
  26.        Acknowledgements:
  27.  
  28.        An astronomers' Julian day number is a calendar system which is useful
  29.        over a very large span of time.  (January 1, 1988 A.D. is 2,447,162 in
  30.        this system.)  The mathematics of these procedures originally restricted
  31.        the valid range to March 1, 0000 through February 28, 4000.  The update
  32.        by Carley Phillips changes the valid end date to December 31, 65535.
  33.  
  34.        The basic algorithms are based on those contained in the COLLECTED
  35.        ALGORITHMS from Communications of the ACM, algorithm number 199,
  36.        originally submitted by Robert G. Tantzen in the August, 1963 issue
  37.        (Volume 6, Number 8).  Note that these algorithms do not take into
  38.        account that years divisible by 4000 are NOT leap years.  Therefore the
  39.        calculations are only valid until 02-28-4000.  These procedures were
  40.        modified by Carley Phillips (76630,3312) to provide a mathematically
  41.        valid range of 03-01-0000 through 12-31-65535.
  42.  
  43.        The main part of Tantzen's original algorithm depends on treating
  44.        January and February as the last months of the preceding year.  Then,
  45.        one can look at a series of four years (for example, 3-1-84 through
  46.        2-29-88) in which the last day will be either the 1460th or the 1461st
  47.        day depending on whether the 4-year series ended in a leap day.
  48.  
  49.        By assigning a longint julian date, computing differences between
  50.        dates, adding days to an existing date, and other mathematical actions
  51.        become much easier.
  52.  
  53. ------------------------------------------------------------------------------}
  54.  
  55. {$O+}
  56.  
  57. interface
  58.  
  59. uses
  60.    {$IFDEF WINDOWS}
  61.       WinDOS;
  62.    {$ELSE}
  63.       DOS;
  64.    {$ENDIF}
  65.  
  66. const
  67.    GS_Date_JulInv  =  -1;             {constant for invalid Julian day}
  68.  
  69. type
  70.    GS_Date_StrTyp  = string[10];
  71.    GS_Date_ValTyp  = longint;
  72.    GS_Date_CenTyp  = string[2];
  73.    DateCountry = (American,ANSI,British,French,German,Italian,Japan,
  74.                   USA, MDY, DMY, YMD);
  75.  
  76. var
  77.    GS_Date_Century : boolean;
  78.    GS_Date_Type    : DateCountry;
  79.  
  80. function  GS_Date_CurCentury : GS_Date_CenTyp;
  81. function  GS_Date_Curr : GS_Date_ValTyp;
  82. function  GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  83. function  GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  84. function  GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  85. function  GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  86. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  87.  
  88.  
  89. implementation
  90.  
  91. const
  92.    JulianConstant =  1721119;  {constant for Julian day for 02-28-0000}
  93.    JulianMin      =  1721120;  {constant for Julian day for 03-01-0000}
  94.    JulianMax      =  25657575; {constant for Julian day for 12-31-65535}
  95.  
  96.    ThisCentury : GS_Date_CenTyp = '';
  97.  
  98. type
  99.    Str4 = string[4];
  100.  
  101.  
  102. function DateType_MDY(mm, dd, yy: Str4): GS_Date_StrTyp;
  103. var
  104.    ss  : string[10];
  105. begin
  106.    case GS_Date_Type of
  107.       American,
  108.       MDY         : ss := '  /  /    ';
  109.       USA         : ss := '  -  -    ';
  110.    end;
  111.    if GS_Date_Century then ss[0] := #10 else ss[0] := #8;
  112.    if mm <> '' then
  113.    begin
  114.       move(mm[1],ss[1],2);
  115.       move(dd[1],ss[4],2);
  116.       if GS_Date_Century then
  117.          move(yy[1],ss[7],4)
  118.       else
  119.          move(yy[3],ss[7],2);
  120.    end;
  121.    DateType_MDY := ss;
  122. end;
  123.  
  124. function DateType_DMY(mm, dd, yy: Str4): GS_Date_StrTyp;
  125. var
  126.    ss  : string[10];
  127. begin
  128.    case GS_Date_Type of
  129.       British,
  130.       French,
  131.       DMY         : ss := '  /  /    ';
  132.       German      : ss := '  .  .    ';
  133.       Italian     : ss := '  -  -    ';
  134.    end;
  135.    if GS_Date_Century then ss[0] := #10 else ss[0] := #8;
  136.    if mm <> '' then
  137.    begin
  138.       move(dd[1],ss[1],2);
  139.       move(mm[1],ss[4],2);
  140.       if GS_Date_Century then
  141.          move(yy[1],ss[7],4)
  142.       else
  143.          move(yy[3],ss[7],2);
  144.    end;
  145.    DateType_DMY := ss;
  146. end;
  147.  
  148. function DateType_YMD(mm, dd, yy: Str4): GS_Date_StrTyp;
  149. var
  150.    ss  : string[10];
  151. begin
  152.    case GS_Date_Type of
  153.       Japan,
  154.       YMD         : ss := '    /  /  ';
  155.       ANSI        : ss := '    .  .  ';
  156.    end;
  157.    if not GS_Date_Century then system.Delete(ss,1,2);
  158.    if mm <> '' then
  159.    begin
  160.       if GS_Date_Century then
  161.       begin
  162.          move(yy[1],ss[1],4);
  163.          move(mm[1],ss[6],2);
  164.          move(dd[1],ss[9],2);
  165.       end
  166.       else
  167.       begin
  168.          move(yy[3],ss[1],2);
  169.          move(mm[1],ss[4],2);
  170.          move(dd[1],ss[7],2);
  171.       end;
  172.    end;
  173.    DateType_YMD := ss;
  174. end;
  175.  
  176. function LeapYearTrue (year : word)  : boolean;
  177. begin
  178.    LeapYearTrue := false;
  179.    if (year mod 4 = 0) then
  180.       if (year mod 100 <> 0) or (year mod 400 = 0) then
  181.          if (year mod 4000 <> 0) then
  182.             LeapYearTrue :=  true;
  183. end;
  184.  
  185. function DateOk (month, day, year  : word) : boolean;
  186. var
  187.    daz : integer;
  188. begin
  189.    if (day <> 0) and
  190.       ((month > 0) and (month < 13)) and
  191.       ((year <> 0) or (month > 2)) then
  192.    begin
  193.       case month of
  194.          2  : begin
  195.                  daz := 28;
  196.                  if (LeapYearTrue(year)) then inc(daz);
  197.               end;
  198.          4,
  199.          6,
  200.          9,
  201.          11 : daz := 30;
  202.          else  daz := 31;
  203.       end;
  204.       DateOk := day <= daz;
  205.    end
  206.    else DateOk := false;
  207. end;
  208.  
  209. function GS_Date_MDY2Jul(month, day, year : word) : GS_Date_ValTyp;
  210. var
  211.    wmm,
  212.    wyy,
  213.    jul  : longint;
  214. begin
  215.    wyy := year;
  216.    if (month > 2) then wmm  := month - 3
  217.       else
  218.       begin
  219.          wmm := month + 9;
  220.          dec(wyy);
  221.       end;
  222.    jul := (wyy div 4000) * 1460969;
  223.    wyy := (wyy mod 4000);
  224.    jul := jul +
  225.             (((wyy div 100) * 146097) div 4) +
  226.             (((wyy mod 100) * 1461) div 4) +
  227.             (((153 * wmm) + 2) div 5) +
  228.             day +
  229.             JulianConstant;
  230.    if (jul < JulianMin) or (JulianMax < jul) then
  231.       jul := GS_Date_JulInv;
  232.    GS_Date_MDY2Jul := jul;
  233. end;
  234.  
  235. procedure GS_Date_Jul2MDY(jul : GS_Date_ValTyp; var month, day, year  : word);
  236. var
  237.    tmp1 : longint;
  238.    tmp2 : longint;
  239. begin
  240.    if (JulianMin <= jul) and (jul <= JulianMax) then
  241.       begin
  242.          tmp1  := jul - JulianConstant; {will be at least 1}
  243.          year  := ((tmp1-1) div 1460969) * 4000;
  244.          tmp1  := ((tmp1-1) mod 1460969) + 1;
  245.          tmp1  := (4 * tmp1) - 1;
  246.          tmp2  := (4 * ((tmp1 mod 146097) div 4)) + 3;
  247.          year  := (100 * (tmp1 div 146097)) + (tmp2 div 1461) + year;
  248.          tmp1  := (5 * (((tmp2 mod 1461) + 4) div 4)) - 3;
  249.          month :=   tmp1 div 153;
  250.          day   := ((tmp1 mod 153) + 5) div 5;
  251.          if (month < 10) then
  252.             month  := month + 3
  253.          else
  254.             begin
  255.                month  := month - 9;
  256.                year := year + 1;
  257.             end {else}
  258.       end {if}
  259.    else
  260.       begin
  261.          month := 0;
  262.          day   := 0;
  263.          year  := 0;
  264.       end; {else}
  265. end;
  266.  
  267. function  GS_Date_CurCentury : GS_Date_CenTyp;
  268. Var
  269.   month, day, year : word;
  270.   cw : word;
  271. begin
  272.    if ThisCentury = '' then
  273.    begin
  274.       GetDate(year,month,day,cw);
  275.       year := year div 100;
  276.       Str(year:2, ThisCentury);
  277.    end;
  278.    GS_Date_CurCentury := ThisCentury
  279. end;
  280.  
  281. function GS_Date_Curr : GS_Date_ValTyp;
  282. Var
  283.   month, day, year : word;
  284.   cw : word;
  285. begin
  286.    GetDate(year,month,day,cw);
  287.    GS_Date_Curr := GS_Date_MDY2Jul(month, day, year);
  288. end;
  289.  
  290. function GS_Date_DBStor(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  291. var
  292.    mm,
  293.    dd,
  294.    yy  : word;
  295.    ss  : string[8];
  296.    sg  : string[4];
  297.    i   : integer;
  298. begin
  299.    ss := '        ';
  300.    if nv > GS_Date_JulInv then
  301.    begin
  302.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  303.       str(mm:2,sg);
  304.       move(sg[1],ss[5],2);
  305.       str(dd:2,sg);
  306.       move(sg[1],ss[7],2);
  307.       str(yy:4,sg);
  308.       move(sg[1],ss[1],4);
  309.       for i := 1 to 8 do if ss[i] = ' ' then ss[i] := '0';
  310.    end;
  311.    GS_Date_DBStor := ss;
  312. end;
  313.  
  314. function GS_Date_View(nv : GS_Date_ValTyp) : GS_Date_StrTyp;
  315. var
  316.    mm,
  317.    dd,
  318.    yy  : word;
  319.    ss  : string[10];
  320.    sg1,
  321.    sg2,
  322.    sg3 : string[4];
  323.    i   : integer;
  324. begin
  325.    if nv > GS_Date_JulInv then
  326.    begin
  327.       GS_Date_Jul2MDY(nv,mm,dd,yy);
  328.       if mm = 0 then sg1 := ''
  329.       else
  330.       begin
  331.          str(mm:2,sg1);
  332.          str(dd:2,sg2);
  333.          str(yy:4,sg3);
  334.       end;
  335.    end else sg1 := '';
  336.    case GS_Date_Type of
  337.          American,
  338.          USA,
  339.          MDY          : ss := DateType_MDY(sg1,sg2,sg3);
  340.  
  341.          British,
  342.          French,
  343.          German,
  344.          Italian,
  345.          DMY          : ss := DateType_DMY(sg1,sg2,sg3);
  346.  
  347.          ANSI,
  348.          Japan,
  349.          YMD         : ss := DateType_YMD(sg1,sg2,sg3);
  350.       end;
  351.    if sg1 <> '' then
  352.       for i := 1 to length(ss) do if ss[i] = ' ' then ss[i] := '0';
  353.    GS_Date_View := ss;
  354. end;
  355.  
  356. function GS_Date_Juln(sdate : GS_Date_StrTyp) : GS_Date_ValTyp;
  357. var
  358.    t      : string[10];
  359.    valu,
  360.    yy,
  361.    mm,
  362.    dd     : string[4];
  363.    mmn,
  364.    ddn,
  365.    yyn    : word;
  366.    i      : integer;
  367.    rsl    : integer;
  368.    okDate : boolean;
  369.    co     : longint;
  370. begin
  371.    mm:= '';
  372.    dd := '';
  373.    yy := '';
  374.    t := sdate;
  375.    rsl := 0;
  376.    for i := length(t) downto 1 do
  377.       if t[i] < '0' then rsl := i;
  378.    if rsl = 0 then
  379.    begin
  380.       mm := copy(t,5,2);
  381.       dd := copy(t,7,2);
  382.       yy := copy(t,1,4);
  383.    end
  384.    else
  385.    begin
  386.       case GS_Date_Type of
  387.          American,
  388.          USA,
  389.          MDY          : begin
  390.                            mm := copy(t,1,2);
  391.                            dd := copy(t,4,2);
  392.                            yy := copy(t,7,4);
  393.                         end;
  394.          British,
  395.          French,
  396.          German,
  397.          Italian,
  398.          DMY          : begin
  399.                            dd := copy(t,1,2);
  400.                            mm := copy(t,4,2);
  401.                            yy := copy(t,7,4);
  402.                         end;
  403.          Japan,
  404.          YMD         : begin
  405.                            yy := copy(t,1,rsl-1);
  406.                            mm := copy(t,rsl+1,2);
  407.                            dd := copy(t,rsl+4,2);
  408.                         end;
  409.       end;
  410.       if length(yy) = 2 then yy := GS_Date_CurCentury+yy;
  411.    end;
  412.    okDate := false;
  413.    val(mm,mmn,rsl);
  414.    if rsl = 0 then
  415.    begin
  416.       val(dd,ddn,rsl);
  417.       if rsl = 0 then
  418.       begin
  419.          val(yy,yyn,rsl);
  420.          if rsl = 0 then
  421.          begin
  422.             if DateOk(mmn,ddn,yyn) then okDate := true;
  423.          end;
  424.       end;
  425.    end;
  426.    if not okDate then
  427.       co := GS_Date_JulInv
  428.    else
  429.    begin
  430.       co := GS_Date_MDY2Jul(mmn, ddn, yyn);
  431.    end;
  432.    GS_Date_Juln := co;
  433. end;
  434.  
  435. begin
  436.    GS_Date_Century := false;
  437.    GS_Date_Type := American;
  438. end.
  439.